home *** CD-ROM | disk | FTP | other *** search
/ Windows 6-Pak - Disc 5 / Windows 6-Pak (InfoMagic) (Disc 5) (1999).ISO / Misc-Programming-Tools / PLDB10-16.exe / data.z / PerlDB.pl < prev    next >
Encoding:
Perl Script  |  1998-04-16  |  14.4 KB  |  693 lines
  1. #
  2. # PerlDB.pl
  3. #
  4. # Modified version of perl5db.pl for use with the
  5. # ActiveState Perl Debugger(tm).
  6. #
  7. # Copyright (c) 1998, ActiveState Tool Corp.
  8. #.......................................................
  9.  
  10. # Debugger package
  11. package DB;
  12.  
  13. # check for a valid script before we even create OLE objects and start up
  14. # if no script then they wanted to go into the console mode debugger.
  15. # if no -e either, same thing.
  16. # 
  17. if ( $0 =~ /^-e/ || $0 eq "-" ) { 
  18.     print STDERR "No Source file, Assuming Console Debug mode\n"; 
  19.     require 'Perl5DB.pl'; 
  20.     # dump out of here and run the perl5 debugger off the @INCS list.
  21.     # its begin block will take over.
  22.     #
  23.  
  24.     }
  25.  
  26. else
  27. {
  28.  
  29.  
  30. # Check which OLE is avaialable to us
  31. $AS_OLE = 1;
  32. eval 'use OLE;';
  33. if ($@ ne '') {
  34.     eval 'use Win32::OLE;';
  35.     if ($@ ne '') {
  36.         
  37.         die "Perl Debugger requires either the OLE or the Win32::OLE module extension.\n$@";
  38.     }
  39.     else{
  40.         $AS_OLE = 0;
  41.     }
  42. }
  43.  
  44.  
  45.  
  46.  
  47.  
  48. # open Perl Debugger
  49. # hacked for current Win32::OLE.pm module
  50. if ($AS_OLE == 1)
  51. {
  52.     $app = CreateObject OLE 'PerlDebugger.Document';
  53. }
  54. else
  55. {
  56.     $app = new Win32::OLE 'PerlDebugger.Document';
  57. }
  58.  
  59. if (!$app)
  60. {
  61.     print "Failed to start the ActiveState Perl Debugger.\n";
  62.     print "Please ensure that the ActiveState Perl Debugger is properly installed " .
  63.         "and try again.\n";
  64.     exit 1;
  65. }
  66.  
  67. # debug output?
  68. $ldebug = 0;
  69.  
  70. # maximum length of watch results
  71. $MAX_WATCH_LEN = 2000;
  72.  
  73. # more stuff
  74. require Config;
  75. require Cwd;
  76.  
  77. # get current directory
  78. $cwd = Cwd::getcwd();
  79.  
  80. # notify app of current directory
  81. $app->SetCurrentDirectory($cwd);
  82. print STDERR "Current Directory: $cwd\n" if $ldebug;
  83.  
  84. # turn off warnings (?)
  85. local($^W) = 0;
  86.  
  87. # set console file name
  88. $console = "con";
  89.  
  90. # set name of file with initialization code
  91. $rcfile = "perldb.ini";
  92.  
  93. # open input and output (to and from console)
  94. open(IN, "<$console") || open(IN,  "<&STDIN");
  95. open(OUT,">$console") || open(OUT, ">&STDERR") || open(OUT, ">&STDOUT");
  96.  
  97. # force autoflush of output
  98. select(OUT);
  99. $| = 1;                # for DB::OUT
  100. select(STDOUT);
  101. $| = 1;                # for real STDOUT
  102.  
  103. # to avoid warnings?
  104. $sub = '';
  105. @ARGS;
  106.  
  107. #
  108. # DB
  109. #
  110. # Main debugger subroutine
  111. #
  112. sub DB
  113. {
  114.     # do important stuff
  115.     &save;
  116.     ($pkg, $filename, $line) = caller;
  117.     $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
  118.     "package $pkg;";        # this won't let them modify, alas
  119.     local(*dbline) = "::_<$filename";
  120.     $max = $#dbline;
  121.     if (($stop,$action) = split(/\0/,$dbline{$line}))
  122.     {
  123.         if ($stop eq '1')
  124.         {
  125.             $signal |= 1;
  126.         }
  127.         else
  128.         {
  129.             $evalarg = "\$DB::signal |= do {$stop;}"; &eval;
  130.             $dbline{$line} =~ s/;9($|\0)/$1/;
  131.         }
  132.     }
  133.     if ($single || $trace || $signal)
  134.     {
  135.         # update watch variables first
  136.         $updatestatus = 1;
  137.  
  138.         # more important stuff
  139.         $prefix = $sub =~ /'|::/ ? "" : "${pkg}::";
  140.         $prefix .= "$sub($filename:";
  141.         if (length($prefix) > 30)
  142.         {
  143.             $prefix = "";
  144.             $infix = ":\t";
  145.         }
  146.         else
  147.         {
  148.             $infix = "):\t";
  149.         }
  150.         for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i)
  151.         {
  152.             last if $dbline[$i] =~ /^\s*(}|#|\n)/;
  153.         }
  154.     }
  155.     $evalarg = $action, &eval if $action;
  156.     if ($single || $signal)
  157.     {
  158.         print OUT $#stack . " levels deep in subroutine calls!\n"
  159.             if $single & 4;
  160.  
  161.         # command loop
  162.         CMD:
  163.         while (print OUT "")
  164.         {
  165.             # never stop in OLE.pm
  166.             last CMD if lc(substr($filename,-6)) eq "ole.pm";
  167.  
  168.             # tell LPD where the source file is
  169.             $app->{'SourceFile'} = "$filename";
  170.             $app->{'LineNumber'} = int $line;
  171.  
  172.             # debug message
  173.             print STDERR "Source: $filename (line $line)\n" if $ldebug;
  174.  
  175.             # check if we're immediately updating
  176.             if ($updatestatus)
  177.             {
  178.                 # update status now
  179.                 $cmd = "UpdateStatus";
  180.                 $updatestatus = 0;
  181.  
  182.                 # debug message
  183.                 print STDERR "Command: $cmd\n" if $ldebug;
  184.             }
  185.             else
  186.             {
  187.                 # tell program we're ready
  188.                 $app->{'Command'} = "";
  189.  
  190.                 # wait for command string
  191.                 do
  192.                 {
  193.                     # give a little time to Windows
  194. #DH: hack to take out currently, will chew up lots of processor resources like this though
  195. #                    Win32::Sleep(0);
  196.                     sleep(0);
  197.  
  198.                     # get command string from Windows program
  199.                     $cmd = $app->{'Command'};
  200.                 }
  201.                 while ($cmd eq "");
  202.  
  203.                 # debug message
  204.                 print STDERR "Command: $cmd\n" if $ldebug;
  205.             }
  206.  
  207.             # more important stuff
  208.             $single = 0;
  209.             $signal = 0;
  210.             $cmd eq '' && exit 0;
  211.  
  212.             # check command
  213.             if ($cmd eq "Quit")
  214.             {
  215.                 # debug message
  216.                 print STDERR "Exiting script..." if $ldebug;
  217.  
  218.                 # exit script
  219.                 exit 0;
  220.             }
  221.             elsif ($cmd eq "RemoveAllBreakpoints")
  222.             {
  223.                 # debug message
  224.                 print STDERR "Removing all breakpoints...\n" if $ldebug;
  225.  
  226.                 # iterate lines and delete breakpoints
  227.                 for ($i = 1; $i <= $max ; $i++)
  228.                 {
  229.                     if (defined $dbline{$i})
  230.                     {
  231.                         $dbline{$i} =~ s/^[^\0]+//;
  232.                         if ($dbline{$i} =~ s/^\0?$//)
  233.                         {
  234.                             delete $dbline{$i};
  235.                         }
  236.                     }
  237.                 }
  238.  
  239.                 # notify window
  240.                 $app->RemoveAllBreakpoints();
  241.             }
  242.             elsif (substr($cmd,0,19) eq "CanInsertBreakpoint")
  243.             {
  244.                 # grab line number and condition
  245.                 $i = int substr($cmd,20,9);
  246.  
  247.                 # debug message
  248.                 print STDERR "Checking if breakpoint allowed at line $i...\n" if $ldebug;
  249.  
  250.                 # insert breakpoint
  251.                 if ($i >= 0 && $dbline[$i] != 0)
  252.                 {
  253.                     # say yes
  254.                     $app->{'Response'} = "1";
  255.                 }
  256.                 else
  257.                 {
  258.                     # say no
  259.                     $app->{'Response'} = "0";
  260.                 }
  261.             }
  262.             elsif (substr($cmd,0,16) eq "InsertBreakpoint")
  263.             {
  264.                 # grab line number and condition
  265.                 $i = int substr($cmd,17,9);
  266.                 $cond = substr($cmd,27);
  267.  
  268.                 # find breakable line
  269.                 # while ($dbline[$i] == 0 && $i < $#dbline) { $i++; }
  270.                 # while ($dbline[$i] == 0 && $i >= 0) { $i--; }
  271.  
  272.                 # debug message
  273.                 print STDERR "Inserting breakpoint at line $i (condition ($cond))...\n" if $ldebug;
  274.  
  275.                 # insert breakpoint
  276.                 if ($i >= 0 && $dbline[$i] != 0)
  277.                 {
  278.                     # always remove old breakpoint
  279.                     if ($dbline{$i} ne '')
  280.                     {
  281.                         $dbline{$i} =~ s/^[^\0]*//;
  282.                         delete $dbline{$i} if $dbline{$i} eq '';
  283.                     }
  284.  
  285.                     # insert breakpoint
  286.                     $dbline{$i} =~ s/^[^\0]*/$cond/;
  287.                     $app->InsertBreakpoint(int $i,$cond);
  288.                 }
  289.                 else
  290.                 {
  291.                     # debug message
  292.                     print STDERR "Can't insert breakpoint at line $i...\n" if $ldebug;
  293.                 }
  294.             }
  295.             elsif (substr($cmd,0,16) eq "RemoveBreakpoint")
  296.             {
  297.                 # grab line number
  298.                 $i = int substr($cmd,17,9);
  299.  
  300.                 # find breakable line
  301.                 # while ($dbline[$i] == 0 && $i < $#dbline) { $i++; }
  302.                 # while ($dbline[$i] == 0 && $i >= 0) { $i--; }
  303.  
  304.                 # debug message
  305.                 print STDERR "Removing breakpoint at line $i...\n" if $ldebug;
  306.  
  307.                 # remove breakpoint
  308.                 if ($i >= 0 && $dbline[$i] != 0)
  309.                 {
  310.                     # remove breakpoint
  311.                     $dbline{$i} =~ s/^[^\0]*//;
  312.                     delete $dbline{$i} if $dbline{$i} eq '';
  313.                     $app->RemoveBreakpoint(int $i);
  314.                 }
  315.                 else
  316.                 {
  317.                     # debug message
  318.                     print STDERR "Can't remove breakpoint at line $i...\n" if $ldebug;
  319.                 }
  320.             }
  321.             elsif (substr($cmd,0,16) eq "ToggleBreakpoint")
  322.             {
  323.                 # grab line number
  324.                 $i = int substr($cmd,17,9);
  325.                 $cond = "1";
  326.  
  327.                 # find breakable line
  328.                 while ($dbline[$i] == 0 && $i < $#dbline) { $i++; }
  329.                 while ($dbline[$i] == 0 && $i >= 0) { $i--; }
  330.  
  331.                 # toggle breakpoint
  332.                 if ($i >= 0)
  333.                 {
  334.                     # check if no breakpoint
  335.                     if ($dbline{$i} eq '')
  336.                     {
  337.                         # debug message
  338.                         print STDERR "Inserting breakpoint at line $i (condition ($cond))...\n" if $ldebug;
  339.  
  340.                         # insert breakpoint
  341.                         $dbline{$i} =~ s/^[^\0]*/$cond/;
  342.                         $app->InsertBreakpoint(int $i,$cond);
  343.                     }
  344.                     else
  345.                     {
  346.                         # debug message
  347.                         print STDERR "Removing breakpoint at line $i...\n" if $ldebug;
  348.  
  349.                         # remove breakpoint
  350.                         $dbline{$i} =~ s/^[^\0]*//;
  351.                         delete $dbline{$i} if $dbline{$i} eq '';
  352.                         $app->RemoveBreakpoint(int $i);
  353.                     }
  354.                 }
  355.             }
  356.             elsif ($cmd eq "StepOver")
  357.             {
  358.                 # debug message
  359.                 print STDERR "Stepping over...\n" if $ldebug;
  360.  
  361.                 # step over
  362.                 $single = 2;
  363.                 last CMD;
  364.             }
  365.             elsif ($cmd eq "StepInto")
  366.             {
  367.                 # debug message
  368.                 print STDERR "Stepping into...\n" if $ldebug;
  369.  
  370.                 # step into
  371.                 $single = 1;
  372.                 last CMD;
  373.             }
  374.             elsif ($cmd eq "StepOut")
  375.             {
  376.                 # debug message
  377.                 print STDERR "Stepping out...\n" if $ldebug;
  378.  
  379.                 # step out
  380.                 $stack[$#stack] |= 2;
  381.                 last CMD;
  382.             }
  383.             elsif ($cmd eq "Continue")
  384.             {
  385.                 # debug message
  386.                 print STDERR "Continuing...\n" if $ldebug;
  387.  
  388.                 # continue
  389.                 for ($i=0; $i <= $#stack; )
  390.                 {
  391.                     $stack[$i++] &= ~1;
  392.                 }
  393.                 last CMD;
  394.             }
  395.             elsif (substr($cmd,0,11) eq "RunToCursor")
  396.             {
  397.                 # grab line number
  398.                 $i = int substr($cmd,12,9);
  399.  
  400.                 # find breakable line
  401.                 while ($dbline[$i] == 0 && $i < $#dbline) { $i++; }
  402.                 while ($dbline[$i] == 0 && $i >= 0) { $i--; }
  403.  
  404.                 # debug message
  405.                 print STDERR "Running to line $i...\n" if $ldebug;
  406.  
  407.                 # set breakpoint at cursor
  408.                 if ($i >= 0)
  409.                 {
  410.                     # add one-time-only breakpoint
  411.                     $dbline{$i} =~ s/(\0|$)/;9$1/;
  412.                 }
  413.  
  414.                 # continue
  415.                 for ($i=0; $i <= $#stack; )
  416.                 {
  417.                     $stack[$i++] &= ~1;
  418.                 }
  419.                 last CMD;
  420.             }
  421.             elsif ($cmd eq "CallStack")
  422.             {
  423.                 # standard call stack code
  424.                 local($p,$f,$l,$s,$h,$a,@a,@sub,$callnames,$callfiles,$calllines);
  425.                 for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++)
  426.                 {
  427.                     @a = ();
  428.                     for $arg (@args)
  429.                     {
  430.                         $_ = "$arg";
  431.                         s/'/\\'/g;
  432.                         s/([^\0]*)/'$1'/
  433.                         unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
  434.                         s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
  435.                         s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
  436.                         push(@a, $_);
  437.                     }
  438.                     $w = $w ? '@ = ' : '$ = ';
  439.                     $a = $h ? '(' . join(', ', @a) . ')' : '';
  440.                     push(@sub, "$w$s$a from file $f line $l\n");
  441.  
  442.                     # store my way
  443.                     $callnames .= "$w$s$a\n";
  444.                     $callfiles .= "$f\n";
  445.                     $calllines .= "$l\n";
  446.  
  447.                     last if $signal;
  448.                 }
  449.  
  450.                 # send results to app
  451.                 $app->DisplayCallStack($callnames,$callfiles,$calllines);
  452.             }
  453.             elsif ($cmd eq "UpdateStatus")
  454.             {
  455.                 # debug message
  456.                 print STDERR "Updating status...\n" if $ldebug;
  457.  
  458.                 # update status
  459.                 $watchlist = $app->{'WatchList'};
  460.                 @watchlist = split("\n",$watchlist,-1);
  461.  
  462.                 foreach $watchsublist (@watchlist)
  463.                 {
  464.                     @watchsublist = split("\t",$watchsublist,-1);
  465.  
  466.                     foreach $watchexpr (@watchsublist)
  467.                     {
  468.                         $after = "";
  469.                         $evalarg = "\$DB::after = ( " . $watchexpr . " )";
  470.                         &eval;
  471.                         {
  472.                             $after =~ s!\n!\\n!g;
  473.                             $after =~ s!\t!\\t!g;
  474.                             $after =~ s![\x00-\x1f]!.!g;
  475.                         }
  476.                         if (length $after > $MAX_WATCH_LEN)
  477.                         {
  478.                             $watchexpr = substr($after,0,$MAX_WATCH_LEN) . "...";
  479.                         }
  480.                         else
  481.                         {
  482.                             $watchexpr = $after;
  483.                         }
  484.                     }
  485.  
  486.                     $watchsublist = join("\t",@watchsublist);
  487.                 }
  488.  
  489.                 $watchlist = join("\n",@watchlist);
  490.  
  491.                 $app->{'WatchList'} = $watchlist;
  492.             }
  493.             elsif (substr($cmd,0,10) eq "DoWatchTip")
  494.             {
  495.                 # debug message
  496.                 print STDERR "Checking watch tip...\n" if $ldebug;
  497.  
  498.                 # grab line number
  499.                 $watchexpr = substr($cmd,11);
  500.  
  501.                 # calculate watch
  502.                 {
  503.                     $after = "";
  504.                     $evalarg = "\$DB::after = ( " . $watchexpr . " )";
  505.                     &eval;
  506.                     {
  507.                         $after =~ s!\n!\\n!g;
  508.                         $after =~ s!\t!\\t!g;
  509.                         $after =~ s![\x00-\x1f]!.!g;
  510.                     }
  511.                     if (length $after > $MAX_WATCH_LEN)
  512.                     {
  513.                         $watchexpr = substr($after,0,$MAX_WATCH_LEN) . "...";
  514.                     }
  515.                     else
  516.                     {
  517.                         $watchexpr = $after;
  518.                     }
  519.                 }
  520.  
  521.                 # generate response
  522.                 $app->{'Response'} = "$watchexpr\n";
  523.             }
  524.             elsif (substr($cmd,0,12) eq "DumpVariable")
  525.             {
  526.                 # debug message
  527.                 print STDERR "Dumping variable...\n" if $ldebug;
  528.  
  529.                 # grab variable name
  530.                 $varname = substr($cmd,13);
  531.  
  532.                 # remove variable symbol
  533.                 my $varnamechar = substr($varname,0,1);
  534.                 if ($varnamechar eq '$' or
  535.                     $varnamechar eq '@' or
  536.                     $varnamechar eq '%')
  537.                 {
  538.                     $varname = substr($varname,1);
  539.                 }
  540.  
  541.                 # send to temporary file
  542.                 $vardump = $app->GetTempFile();
  543.                 if (open (VARDUMP,">$vardump"))
  544.                 {
  545.                     # select temporary variable
  546.                     local ($saveout) = select(VARDUMP);
  547.  
  548.                     # grab package name and variables
  549.                     $packname = $pkg;
  550.                     @vars = ( $varname );
  551.  
  552.                     # call dumpvar
  553.                     do 'dumpvar.pl' unless defined &main::dumpvar;
  554.                     if (defined &main::dumpvar)
  555.                     {
  556.                         # dump variable
  557.                         &main::dumpvar($packname,@vars);
  558.                     }
  559.                     else
  560.                     {
  561.                         # print error message
  562.                         print DB::OUT "Module 'dumpvar.pl' is not available!\n";
  563.                     }
  564.  
  565.                     # reselect previous output
  566.                     select ($saveout);
  567.  
  568.                     # generate response
  569.                     close (VARDUMP);
  570.                 }
  571.                 else
  572.                 {
  573.                     # error
  574.                     print DB::OUT "Unable to open '$vardump' for output!\n";
  575.                     $vardump = "";
  576.                 }
  577.  
  578.                 # set response
  579.                 $app->{'Response'} = "$vardump\n";
  580.             }
  581.             elsif ($cmd eq "SourceFile")
  582.             {
  583.                 # debug message
  584.                 print STDERR "Sending $filename ($#dbline lines) to debugger...\n" if $ldebug;
  585.  
  586.                 # send line count
  587.                 $app->SetSourceFileLineCount($#dbline);
  588.  
  589.                 # send each line
  590.                 for ($linenum = 1; $linenum <= $#dbline; $linenum++)
  591.                 {
  592.                     $linestr = $dbline[$linenum];
  593.                     chomp $linestr;
  594.                     $app->SetSourceFileLine(int $linenum,$linestr);
  595.                 }
  596.             }
  597.         }
  598.     }
  599.  
  600.     # important stuff
  601.     ($@, $!, $,, $/, $\, $^W) = @saved;
  602.     ();
  603. }
  604.  
  605. #
  606. # save
  607. #
  608. # Save registers.
  609. #
  610. sub save
  611. {
  612.     @saved = ($@, $!, $,, $/, $\, $^W);
  613.     $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
  614. }
  615.  
  616. #
  617. # eval
  618. #
  619. # Evaluate $evalarg (to preserve current @_).
  620. #
  621. sub eval
  622. {
  623.     eval "$usercontext $evalarg; &DB::save";
  624. }
  625.  
  626. #
  627. # catch
  628. #
  629. # Catches exceptions?
  630. #
  631. sub catch
  632. {
  633.     $signal = 1;
  634. }
  635.  
  636. #
  637. # sub
  638. #
  639. # Called automatically?
  640. #
  641. sub sub
  642. {
  643.     push(@stack, $single);
  644.     $single &= 1;
  645.     $single |= 4 if $#stack == $deep;
  646.     if (wantarray)
  647.     {
  648.         @i = &$sub;
  649.         $single |= pop(@stack);
  650.         @i;
  651.     }
  652.     else
  653.     {
  654.         $i = &$sub;
  655.         $single |= pop(@stack);
  656.         $i;
  657.     }
  658. }
  659.  
  660. # uninitialized warning suppression
  661. $trace = $signal = $single = 0;
  662.  
  663. # exception handling?
  664. $SIG{'INT'} = "DB::catch";
  665.  
  666. # some defaults
  667. $deep = 10000;
  668.  
  669. # important stuff
  670. @stack = (0);
  671. @ARGS = @ARGV;
  672. for (@args)
  673. {
  674.     s/'/\\'/g;
  675.     s/(.*)/'$1'/ unless /^-?[\d.]+$/;
  676. }
  677.  
  678. # important stuff?
  679. if (-f $rcfile)
  680. {
  681.     do "./$rcfile";
  682. }
  683. elsif (-f "$ENV{'LOGDIR'}/$rcfile")
  684. {
  685.     do "$ENV{'LOGDIR'}/$rcfile";
  686. }
  687. elsif (-f "$ENV{'HOME'}/$rcfile")
  688. {
  689.     do "$ENV{'HOME'}/$rcfile";
  690. }
  691.  
  692. 1;
  693. }